home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / cmpnew / cmpvar.lsp < prev    next >
Lisp/Scheme  |  1987-06-03  |  14KB  |  345 lines
  1. ;;; CMPVAR  Variables.
  2. ;;;
  3. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  4. ;; Copying of this file is authorized to users who have executed the true and
  5. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  6.  
  7. (in-package 'compiler)
  8.  
  9. (si:putprop 'var 'c2var 'c2)
  10. (si:putprop 'location 'c2location 'c2)
  11. (si:putprop 'setq 'c1setq 'c1special)
  12. (si:putprop 'setq 'c2setq 'c2)
  13. (si:putprop 'progv 'c1progv 'c1special)
  14. (si:putprop 'progv 'c2progv 'c2)
  15. (si:putprop 'psetq 'c1psetq 'c1)
  16. (si:putprop 'psetq 'c2psetq 'c2)
  17.  
  18. (si:putprop 'var 'set-var 'set-loc)
  19. (si:putprop 'var 'wt-var 'wt-loc)
  20.  
  21. (defstruct var
  22.   name        ;;; Variable name.
  23.   kind        ;;; One of LEXICAL, SPECIAL, GLOBAL, REPLACED, FIXNUM,
  24.           ;;; CHARACTER, LONG-FLOAT, SHORT-FLOAT, and OBJECT.
  25.   ref        ;;; Referenced or not.
  26.           ;;; During Pass1, T, NIL, or IGNORE.
  27.           ;;; During Pass2, the vs-address for the variable.
  28.   ref-ccb    ;;; Cross closure reference.
  29.           ;;; During Pass1, T or NIL.
  30.           ;;; During Pass2, the ccb-vs for the variable, or NIL.
  31.   loc        ;;; For SPECIAL and GLOBAL, the vv-index for variable name.
  32.         ;;; For others, this field is used to indicate whether
  33.         ;;; to be allocated on the value-stack: OBJECT means
  34.         ;;; the variable is declared as OBJECT, and CLB means
  35.         ;;; the variable is referenced across Level Boundary and thus
  36.         ;;; cannot be allocated on the C stack.  Note that OBJECT is
  37.         ;;; set during variable binding and CLB is set when the
  38.         ;;; variable is used later, and therefore CLB may supersede
  39.         ;;; OBJECT.
  40.           ;;; For REPLACED, the actual location of the variable.
  41.           ;;; For FIXNUM, CHARACTER, LONG-FLOAT, SHORT-FLOAT, and
  42.           ;;; OBJECT, the cvar for the C variable that holds the value.
  43.           ;;; Not used for LEXICAL.
  44.   (type t)    ;;; Type of the variable.
  45.   )
  46.  
  47. ;;; A special binding creates a var object with the kind field SPECIAL,
  48. ;;; whereas a special declaration without binding creates a var object with
  49. ;;; the kind field GLOBAL.  Thus a reference to GLOBAL may need to make sure
  50. ;;; that the variable has a value.
  51.  
  52. (defvar *vars* nil)
  53. (defvar *undefined-vars* nil)
  54. (defvar *special-binding* nil)
  55.  
  56. ;;; During Pass 1, *vars* holds a list of var objects and the symbols 'CB'
  57. ;;; (Closure Boundary) and 'LB' (Level Boundary).  'CB' will be pushed on
  58. ;;; *vars* when the compiler begins to process a closure.  'LB' will be pushed
  59. ;;; on *vars* when *level* is incremented.
  60. ;;; *GLOBALS* holds a list of var objects for those variables that are
  61. ;;; not defined.  This list is used only to suppress duplicated warnings when
  62. ;;; undefined variables are detected.
  63.  
  64. (defun c1make-var (name specials ignores types &aux x)
  65.   (let ((var (make-var :name name)))
  66.        (cmpck (not (symbolp name)) "The variable ~s is not a symbol." name)
  67.        (cmpck (constantp name) "The constant ~s is being bound." name)
  68.  
  69.        (cond ((or (member name specials) (si:specialp name))
  70.               (setf (var-kind var) 'SPECIAL)
  71.               (setf (var-loc var) (add-symbol name))
  72.               (cond ((setq x (assoc name types))
  73.                      (setf (var-type var) (cdr x)))
  74.                     ((setq x (get name 'cmp-type))
  75.                      (setf (var-type var) x)))
  76.               (setq *special-binding* t))
  77.              (t
  78.               (when (setq x (assoc name types))
  79.                     (if (eq (cdr x) 'object)
  80.                         (setf (var-loc var) 'object)
  81.                         (setf (var-type var) (cdr x))))
  82.               (setf (var-kind var) 'LEXICAL)))
  83.        (when (member name ignores) (setf (var-ref var) 'IGNORE))
  84.        var)
  85.   )
  86.  
  87. (defun check-vref (var)
  88.   (when (and (eq (var-kind var) 'LEXICAL)
  89.              (not (var-ref var)) ;;; This field may be IGNORE.
  90.              (not (var-ref-ccb var)))
  91.         (cmpwarn "The variable ~s is not used." (var-name var))))
  92.  
  93. (defun c1var (name)
  94.   (let ((info (make-info))
  95.         (vref (c1vref name)))
  96.        (push (car vref) (info-referred-vars info))
  97.        (setf (info-type info) (var-type (car vref)))
  98.        (list 'var info vref))
  99.   )
  100.  
  101. ;;; A variable reference (vref for short) is a pair
  102. ;;;    ( var-object  ccb-reference )
  103.  
  104. (defun c1vref (name &aux (ccb nil) (clb nil))
  105.        (declare (object ccb clb))
  106.   (dolist* (var *vars*
  107.                (let ((var (sch-global name)))
  108.                     (unless var
  109.                       (unless (si:specialp name) (undefined-variable name))
  110.                       (setq var (make-var :name name
  111.                                           :kind 'GLOBAL
  112.                                           :loc (add-symbol name)
  113.                                           :type (or (get name 'cmp-type) t)
  114.                                           ))
  115.                       (push var *undefined-vars*))
  116.                     (list var ccb)))
  117.       (cond ((eq var 'cb) (setq ccb t))
  118.             ((eq var 'lb) (setq clb t))
  119.             ((eq (var-name var) name)
  120.              (when (eq (var-ref var) 'IGNORE)
  121.                    (cmpwarn "The ignored variable ~s is used." name)
  122.                    (setf (var-ref var) t))
  123.              (cond (ccb (setf (var-ref-ccb var) t))
  124.                    (clb (when (eq (var-kind var) 'lexical)
  125.                               (setf (var-loc var) 'clb))
  126.                         (setf (var-ref var) t))
  127.                    (t (setf (var-ref var) t)))
  128.              (return-from c1vref (list var ccb)))))
  129.   )
  130.  
  131. (defun c2var-kind (var)
  132.   (if (and (eq (var-kind var) 'LEXICAL)
  133.            (not (var-ref-ccb var))
  134.            (not (eq (var-loc var) 'clb)))
  135.       (if (eq (var-loc var) 'OBJECT)
  136.           'OBJECT
  137.           (let ((type (var-type var)))
  138.                (declare (object type))
  139.                (cond ((type>= 'fixnum type) 'FIXNUM)
  140.                      ((type>= 'CHARACTER type) 'CHARACTER)
  141.                      ((type>= 'long-float type) 'LONG-FLOAT)
  142.                      ((type>= 'short-float type) 'SHORT-FLOAT)
  143.                      (t nil))))
  144.       nil)
  145.   )
  146.  
  147. (defun c2var (vref) (unwind-exit (cons 'var vref)))
  148.  
  149. (defun c2location (loc) (unwind-exit loc))
  150.  
  151. (defun wt-var (var ccb)
  152.   (case (var-kind var)
  153.         (LEXICAL (cond (ccb (wt-ccb-vs (var-ref-ccb var)))
  154.                        ((var-ref-ccb var) (wt-vs* (var-ref var)))
  155.                        (t (wt-vs (var-ref var)))))
  156.         (SPECIAL (wt "(VV[" (var-loc var) "]->s.s_dbind)"))
  157.         (REPLACED (wt (var-loc var)))
  158.         (GLOBAL (if *safe-compile*
  159.                     (wt "symbol_value(VV[" (var-loc var) "])")
  160.                     (wt "(VV[" (var-loc var) "]->s.s_dbind)")))
  161.         (t (case (var-kind var)
  162.                  (FIXNUM (when (zerop *space*) (wt "CMP"))
  163.                          (wt "make_fixnum"))
  164.                  (CHARACTER (wt "code_char"))
  165.                  (LONG-FLOAT (wt "make_longfloat"))
  166.                  (SHORT-FLOAT (wt "make_shortfloat"))
  167.                  (OBJECT)
  168.                  (t (baboon)))
  169.            (wt "(V" (var-loc var) ")"))
  170.         ))
  171.  
  172. (defun set-var (loc var ccb)
  173.   (unless (and (consp loc)
  174.                (eq (car loc) 'var)
  175.                (eq (cadr loc) var)
  176.                (eq (caddr loc) ccb))
  177.           (case (var-kind var)
  178.             (LEXICAL (wt-nl)
  179.                      (cond (ccb (wt-ccb-vs (var-ref-ccb var)))
  180.                            ((var-ref-ccb var) (wt-vs* (var-ref var)))
  181.                            (t (wt-vs (var-ref var))))
  182.                      (wt "= " loc ";"))
  183.             (SPECIAL (wt-nl "(VV[" (var-loc var) "]->s.s_dbind)= " loc ";"))
  184.             (GLOBAL
  185.              (if *safe-compile*
  186.                  (wt-nl "setq(VV[" (var-loc var) "]," loc ");")
  187.                  (wt-nl "(VV[" (var-loc var) "]->s.s_dbind)= " loc ";")))
  188.             (t
  189.              (wt-nl "V" (var-loc var) "= ")
  190.              (case (var-kind var)
  191.                    (FIXNUM (wt-fixnum-loc loc))
  192.                    (CHARACTER (wt-character-loc loc))
  193.                    (LONG-FLOAT (wt-long-float-loc loc))
  194.                    (SHORT-FLOAT (wt-short-float-loc loc))
  195.                    (OBJECT (wt-loc loc))
  196.                    (t (baboon)))
  197.              (wt ";"))
  198.             )))
  199.  
  200. (defun sch-global (name)
  201.   (dolist* (var *undefined-vars* nil)
  202.     (when (eq (var-name var) name) (return-from sch-global var))))
  203.  
  204. (defun c1add-globals (globals)
  205.   (dolist** (name globals)
  206.     (push (make-var :name name
  207.                     :kind 'GLOBAL
  208.                     :loc (add-symbol name)
  209.                     :type (let ((x (get name 'cmp-type))) (if x x t))
  210.                     )
  211.           *vars*))
  212.   )
  213.  
  214. (defun c1setq (args)
  215.   (cond ((endp args) (c1nil))
  216.         ((endp (cdr args)) (too-few-args 'setq 2 1))
  217.         ((endp (cddr args)) (c1setq1 (car args) (cadr args)))
  218.         (t
  219.          (do ((pairs args (cddr pairs))
  220.               (forms nil))
  221.              ((endp pairs) (c1expr (cons 'progn (reverse forms))))
  222.              (declare (object pairs))
  223.              (cmpck (endp (cdr pairs))
  224.                     "No form was given for the value of ~s." (car pairs))
  225.              (push (list 'setq (car pairs) (cadr pairs)) forms)
  226.              )))
  227.   )
  228.  
  229. (defun c1setq1 (name form &aux (info (make-info)) type form1 name1)
  230.   (cmpck (not (symbolp name)) "The variable ~s is not a symbol." name)
  231.   (cmpck (constantp name) "The constant ~s is being assigned a value." name)
  232.   (setq name1 (c1vref name))
  233.   (push (car name1) (info-changed-vars info))
  234.   (setq form1 (c1expr form))
  235.   (add-info info (cadr form1))
  236.   (setq type (type-and (var-type (car name1)) (info-type (cadr form1))))
  237.   (when (null type)
  238.         (cmpwarn "Type mismatches between ~s and ~s." name form))
  239.   (unless (eq type (info-type (cadr form1)))
  240.     (let ((info1 (copy-info (cadr form1))))
  241.          (setf (info-type info1) type)
  242.          (setq form1 (list* (car form1) info1 (cddr form1)))))
  243.   (setf (info-type info) type)
  244.   (list 'setq info name1 form1)
  245.   )
  246.  
  247. (defun c2setq (vref form)
  248.   (let ((*value-to-go* (cons 'var vref))) (c2expr* form))
  249.   (case (car form)
  250.         (LOCATION (c2location (caddr form)))
  251.         (otherwise (unwind-exit (cons 'var vref))))
  252.   )
  253.  
  254. (defun c1progv (args &aux symbols values (info (make-info)))
  255.   (when (or (endp args) (endp (cdr args)))
  256.         (too-few-args 'progv 2 (length args)))
  257.   (setq symbols (c1expr* (car args) info))
  258.   (setq values (c1expr* (cadr args) info))
  259.   (list 'progv info symbols values (c1progn* (cddr args) info))
  260.   )
  261.  
  262. (defun c2progv (symbols values body
  263.                 &aux (cvar (next-cvar))
  264.                      (*unwind-exit* *unwind-exit*))
  265.  
  266.   (wt-nl "{object symbols,values;")
  267.   (wt-nl "bds_ptr V" cvar "=bds_top;")
  268.   (push cvar *unwind-exit*)
  269.  
  270.   (let ((*vs* *vs*))
  271.        (let ((*value-to-go* (list 'vs (vs-push))))
  272.             (c2expr* symbols)
  273.             (wt-nl "symbols= " *value-to-go* ";"))
  274.  
  275.        (let ((*value-to-go* (list 'vs (vs-push))))
  276.             (c2expr* values)
  277.             (wt-nl "values= " *value-to-go* ";"))
  278.  
  279.        (wt-nl "while(!endp(symbols)){")
  280.        (when *safe-compile*
  281.              (wt-nl "if(type_of(MMcar(symbols))!=t_symbol)")
  282.              (wt-nl
  283.               "FEinvalid_variable(\"~s is not a symbol.\",MMcar(symbols));"))
  284.        (wt-nl "if(endp(values))bds_bind(MMcar(symbols),OBJNULL);")
  285.        (wt-nl "else{bds_bind(MMcar(symbols),MMcar(values));")
  286.        (wt-nl "values=MMcdr(values);}")
  287.        (wt-nl "symbols=MMcdr(symbols);}")
  288.        )
  289.   (c2expr body)
  290.   (wt "}")
  291.   )
  292.  
  293. (defun c1psetq (args &aux (vrefs nil) (forms nil)
  294.                           (info (make-info :type '(member nil))))
  295.   (do ((l args (cddr l)))
  296.       ((endp l))
  297.       (declare (object l))
  298.       (cmpck (not (symbolp (car l)))
  299.              "The variable ~s is not a symbol." (car l))
  300.       (cmpck (constantp (car l))
  301.              "The constant ~s is being assigned a value." (car l))
  302.       (cmpck (endp (cdr l))
  303.              "No form was given for the value of ~s." (car l))
  304.       (let* ((vref (c1vref (car l)))
  305.              (form (c1expr (cadr l)))
  306.              (type (type-and (var-type (car vref))
  307.                              (info-type (cadr form)))))
  308.             (unless (equal type (info-type (cadr form)))
  309.               (let ((info1 (copy-info (cadr form))))
  310.                    (setf (info-type info1) type)
  311.                    (setq form (list* (car form) info1 (cddr form)))))
  312.             (push vref vrefs)
  313.             (push form forms)
  314.             (push (car vref) (info-changed-vars info))
  315.             (add-info info (cadar forms)))
  316.       )
  317.   (list 'psetq info (reverse vrefs) (reverse forms))
  318.   )
  319.  
  320. (defun c2psetq (vrefs forms &aux (*vs* *vs*) (saves nil) (blocks 0))
  321.   (dolist** (vref vrefs)
  322.     (if (or (args-info-changed-vars (car vref) (cdr forms))
  323.             (args-info-referred-vars (car vref) (cdr forms)))
  324.         (case (caar forms)
  325.           (LOCATION (push (cons vref (caddar forms)) saves))
  326.           (otherwise
  327.             (if (member (var-kind (car vref))
  328.                         '(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT))
  329.                 (let* ((kind (var-kind (car vref)))
  330.                        (cvar (next-cvar))
  331.                        (temp (list 'var (make-var :kind kind :loc cvar) nil)))
  332.                   (wt-nl "{" (rep-type kind) "V" cvar ";")
  333.                   (incf blocks)
  334.                   (let ((*value-to-go* temp)) (c2expr* (car forms)))
  335.                   (push (cons vref temp) saves))
  336.                 (let ((*value-to-go* (list 'vs (vs-push))))
  337.                   (c2expr* (car forms))
  338.                   (push (cons vref *value-to-go*) saves)))))
  339.         (let ((*value-to-go* (cons 'var vref))) (c2expr* (car forms))))
  340.     (pop forms))
  341.   (dolist** (save saves) (set-var (cdr save) (caar save) (cadar save)))
  342.   (dotimes (i blocks) (wt "}"))
  343.   (unwind-exit nil)
  344.   )
  345.